home *** CD-ROM | disk | FTP | other *** search
/ Windows Expert / Windows Expert.iso / program / vbpxen.zip / PXMODULE.BAS < prev    next >
BASIC Source File  |  1991-10-07  |  14KB  |  417 lines
  1. '
  2. '  Written by Steve Jackson 
  3. '             9152 Brabham Drive
  4. '             Huntington Beach, CA 92646
  5. '
  6. '  Thanks to John Jaster for some of the dll definitions
  7. '
  8. '  Most of the engine functions are defined here, but not all.
  9. '  One that I have not gotten to work is PxErrMsg because it returns
  10. '  a pointer.  Visual Basic has no pointer types (that I know of).  
  11. '  You might get it to work by get a pointer to windows memory and
  12. '  using that, but it is beyond me right now.
  13. '
  14. '  This module is meant to be a general purpose visual basic interface
  15. '  to the Paradox engine DLL.  To run it, you need the DLL from Paradox
  16. '  Engine.  An example of usage is distributed in little video rental 
  17. '  application called VVDEMO.  
  18. '
  19. '  Comments, questions are welcome.  If you know of any ways I can
  20. '  earn a little extra income to purchase a faster computer (and with
  21. '  more memory) that would be welcome too.
  22. ' 
  23. '******* Declarations for Using the Paradox 3.5 Engine ******
  24. Declare Function PXWinInit Lib "Pxengwin.dll" (ByVal Application$, ByVal Mode%) As Integer
  25. Declare Function PXExit Lib "Pxengwin.dll" () As Integer
  26. '************ TABLE FUNCTIONS *****************
  27. Declare Function PXTblOpen Lib "Pxengwin.dll" (ByVal TblName$, TblHnd%, ByVal index%, ByVal change%) As Integer
  28. Declare Function PXTblClose Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  29. '************* RECORD FUNCTIONS *******************
  30. Declare Function PXRecAppend Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
  31. Declare Function PXRecInsert Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
  32. Declare Function PXRecUpdate Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
  33. Declare Function PXRecDelete Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  34. Declare Function PXRecBufOpen Lib "Pxengwin.dll" (ByVal TblHnd%, RecHnd%) As Integer
  35. Declare Function PXRecBufClose Lib "Pxengwin.dll" (ByVal RecHnd%) As Integer
  36. Declare Function PXRecBufEmpty Lib "Pxengwin.dll" (ByVal RecHnd%) As Integer
  37. Declare Function PXRecGet Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%) As Integer
  38. Declare Function PXRecFirst Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  39. Declare Function PXRecLast Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  40. Declare Function PXRecNext Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  41. Declare Function PXRecPrev Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  42. Declare Function PXRecNum Lib "Pxengwin.dll" (ByVal TblHnd%, RecNum%) As Integer
  43. Declare Function PXTblNRecs Lib "Pxengwin.dll" (ByVal TblHnd%, nRecs%) As Integer
  44. '**************** FIELD FUNCTIONS ****************
  45. Declare Function PXPutShort Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal sValue%) As Integer
  46. Declare Function PXPutDoub Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal dValue#) As Integer
  47. Declare Function PXPutLong Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal lValue&) As Integer
  48. Declare Function PXPutAlpha Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal aValue$) As Integer
  49. Declare Function PXPutBlank Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%) As Integer
  50. Declare Function PXPutDate Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal inDate As Any) As Integer
  51. Declare Function PXGetShort Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, sValue%) As Integer
  52. Declare Function PXGetDoub Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, dValue#) As Integer
  53. Declare Function PXGetLong Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, lValue&) As Integer
  54. Declare Function PXGetAlpha Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, ByVal bufSize%, ByVal aValue$) As Integer
  55. Declare Function PXFldBlank Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, Blank%) As Integer
  56. Declare Function PXGetDate Lib "Pxengwin.dll" (ByVal RecHnd%, ByVal FldHnd%, outDate As Any) As Integer
  57. Declare Function PXRecNFlds Lib "Pxengwin.dll" (ByVal TblHnd%, nFlds%) As Integer
  58. Declare Function PXFldHandle Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal FldName$, FldHnd%) As Integer
  59. Declare Function PXFldType Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal FldHnd%, ByVal BufSiz%, ByVal fldtype$) As Integer
  60. Declare Function PXFldName Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal FldHnd%, ByVal BufSiz%, ByVal FldName$) As Integer
  61. '*************** SEARCH FUNCTIONS *******************
  62. Declare Function PXSrchKey Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%, ByVal nFlds%, ByVal Mode%) As Integer
  63. Declare Function PXSrchFld Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal RecHnd%, ByVal FldNum%, ByVal Mode%) As Integer
  64. '***************** MISCELLANEOUS FUNCTIONS ****************
  65. Declare Function PXDateDecode Lib "Pxengwin.dll" (ByVal outDate As Any, mm%, dd%, yy%) As Integer
  66. Declare Function PXDateEncode Lib "Pxengwin.dll" (ByVal mm%, ByVal dd%, ByVal yy%, pDate&) As Integer
  67. ' note: PXErrMsg returns a string, not an integer
  68. Declare Function PXErrMsg Lib "Pxengwin.dll" (ByVal error_code%) As String
  69. '******************* NETWORK FUNCTIONS ******************
  70. Declare Function PXNetUserName Lib "Pxengwin.dll" (ByVal buffer%, UserName$) As Integer
  71. Declare Function PXNetFileLock Lib "Pxengwin.dll" (ByVal FileName$, ByVal lockType%) As Integer
  72. Declare Function PXNetFileUnlock Lib "Pxengwin.dll" (ByVal FileName$, ByVal lockType%) As Integer
  73. Declare Function PXNetTblLock Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal lockType%) As Integer
  74. Declare Function PXNetTblUnlock Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal lockType%) As Integer
  75. Declare Function PXNetRecLock Lib "Pxengwin.dll" (ByVal TblHnd%, LockHnd%) As Integer
  76. Declare Function PXNetRecUnlock Lib "Pxengwin.dll" (ByVal TblHnd%, ByVal LockHnd%) As Integer
  77. Declare Function PXNetRecLocked Lib "Pxengwin.dll" (ByVal TblHnd%, Locked%) As Integer
  78. Declare Function PXNetTblChanged Lib "Pxengwin.dll" (ByVal TblHnd%, Changed%) As Integer
  79. Declare Function PXNetTblRefresh Lib "Pxengwin.dll" (ByVal TblHnd%) As Integer
  80. '
  81. ' Variables used only in this module
  82. '
  83. ' What must be defined in global:  NUMBER_OF_TABLES
  84. '
  85. '
  86. Dim hTable(NUMBER_OF_TABLES) As Integer
  87. Dim hRecBuf(NUMBER_OF_TABLES) As Integer
  88. Dim hRecLock(NUMBER_OF_TABLES) As Integer
  89. Dim iTableIsClosed(NUMBER_OF_TABLES) As Integer
  90.  
  91. Dim alpha_field As String * 256
  92. Dim px As Integer
  93.  
  94. Const PX_OK = 0
  95. Const PX_ENDOFTABLE = 101
  96. Const PX_STARTOFTABLE = 102
  97. Const PX_RECNOTFOUND = 89
  98. Const PX_KEYVIOL = 97
  99. Const PX_RECDELETED = 50
  100. Const PX_RECLOCKED = 9
  101.  
  102. Sub PXError (ByVal error_code As Integer)
  103.     '
  104.     '  General purpose error trapping.
  105.     '  If the error is not critical (that is, the database is OK),
  106.     '  return to the user.  Store message that they can retrieve if
  107.     '  needed by calling dberrormsg().
  108.     '
  109.     '  If the error is critical, processing cannot continue, and
  110.     '  this routine will END THE PROGRAM
  111.     '
  112.     If error_code = PX_OK Then
  113.         Exit Sub
  114.     End If
  115.     '
  116.     '   Non-critical errors:
  117.     '
  118.     Select Case error_code
  119.         Case PX_OK
  120.             Exit Sub
  121.         Case PX_ENDOFTABLE, PX_STARTOFTABLE, PX_KEYVIOL
  122.             Exit Sub
  123.         Case PX_RECNOTFOUND, PX_RECDELETED
  124.             Exit Sub
  125.     End Select
  126.  
  127.     Msg$ = "Paradox database error code: " + Str$(error_code)
  128.     ' alpha_field = PXErrMsg(error_code)
  129.     ' Msg$ = Msg$ + alpha_field
  130.     MsgBox Msg$, 0 + 16, "Database Error"
  131.     End
  132. End Sub
  133.  
  134. Function DBInit (ByVal AppName$) As Integer
  135.     '
  136.     ' Start the paradox engine for windows
  137.     ' for now always use mode of: PXSHARED
  138.     '
  139.     px = PXWinInit(AppName$, 2)
  140.     If px = 82 Then
  141.         DBInit = PX_OK
  142.         Exit Function
  143.     End If
  144.  
  145.     If px Then
  146.         Msg$ = "Unable to start Paradox engine, code: " + Str$(px)
  147.         Msg$ = Msg$ + " Remember to type SHARE before starting Windows"
  148.         MsgBox Msg$, 0 + 16, "Database Initialization"
  149.         End
  150.     End If
  151.  
  152.     DBInit = PX_OK
  153. End Function
  154.  
  155. Function DBExit () As Integer
  156.     '
  157.     '  Shutdown the paradox engine
  158.     '
  159.     DBExit = PXExit()
  160. End Function
  161.  
  162. Function TableOpen (ByVal Tblnum%, ByVal TblName$)
  163.     '
  164.     '  Open a table and allocate one record buffer for it.
  165.     '  Application calls this routine once for each table.
  166.     '  Note that it creates table and record handles for use in
  167.     '  other database routines.  They get the correct handles by
  168.     '  indexing into the handle array with the application assigned
  169.     '  table id - should be a const in their global declaration,
  170.     '  and MUST be sequentially assigned starting at ZERO.
  171.     '
  172.     px = PXTblOpen(TblName$, TblHnd%, 0, TRUE)
  173.     PXError (px)
  174.  
  175.     px = PXRecBufOpen(TblHnd%, RecHnd%)
  176.     PXError (px)
  177.  
  178.     px = PXRecBufEmpty(RecHnd%)
  179.     PXError (px)
  180.  
  181.     hTable(Tblnum%) = TblHnd%
  182.     hRecBuf(Tblnum%) = RecHnd%
  183.  
  184.     TableOpen = PX_OK
  185. End Function
  186.  
  187. Function GetRec (ByVal Tblnum%, ByVal Action%)
  188.     '
  189.     '  Get a record and move it to the record buffer.
  190.     '  Note that it uses table and record handles created in TableOpen()
  191.     '
  192.     hTbl% = hTable(Tblnum%)
  193.     hrec% = hRecBuf(Tblnum%)
  194.  
  195.     Select Case Action%
  196.          Case DBKEYED
  197.             px = PXSrchKey(hTbl%, hrec%, 1, 0)
  198.             PXError (px)
  199.          Case DBFIRST
  200.             px = PXRecFirst(hTbl%)
  201.             '  check for end, not found, etc.
  202.             PXError (px)
  203.          Case DBNEXT
  204.             px = PXRecNext(hTbl%)
  205.             PXError (px)
  206.          Case DBPRIOR
  207.             px = PXRecPrev(hTbl%)
  208.             PXError (px)
  209.          Case DBLAST
  210.             px = PXRecLast(hTbl%)
  211.             PXError (px)
  212.     End Select
  213.  
  214.     If px Then
  215.         GetRec = px
  216.         Exit Function
  217.     End If
  218.  
  219.     px = PXRecGet(hTbl%, hrec%)
  220.     PXError (px)
  221.  
  222.     GetRec = PX_OK
  223. End Function
  224.  
  225. '
  226. Function UpdateRec (ByVal Tblnum%) As Integer
  227.     '
  228.     '  Uupdate the record that is current  (last one retrieved)
  229.     '
  230.     hTbl% = hTable(Tblnum%)
  231.     hrec% = hRecBuf(Tblnum%)
  232.  
  233.     px = PXRecUpdate(hTbl%, hrec%)
  234.     PXError (px)
  235.  
  236.     UpdateRec = px
  237.  
  238. End Function
  239.  
  240. Function AddRec (ByVal Tblnum%) As Integer
  241.     '
  242.     '  Add a new record.  If file is not indexed, goes at end
  243.     '
  244.     hTbl% = hTable(Tblnum%)
  245.     hrec% = hRecBuf(Tblnum%)
  246.  
  247.     px = PXRecAppend(hTbl%, hrec%)
  248.     PXError (px)
  249.  
  250.     AddRec = px
  251.  
  252. End Function
  253.  
  254. Function DeleteRec (ByVal Tblnum%) As Integer
  255.     '
  256.     '  Delete current record (most recently retrieved)
  257.     '
  258.     hTbl% = hTable(Tblnum%)
  259.  
  260.     px = PXRecDelete(hTbl%)
  261.     PXError (px)
  262.  
  263.     DeleteRec = px
  264.  
  265. End Function
  266.  
  267. Function PutAlphaField (ByVal TableNum%, ByVal FieldNum%, ByVal FieldVal$) As Integer
  268.     '
  269.     '  Move field to paradox buffer
  270.     '
  271.     hrec% = hRecBuf(TableNum%)
  272.     alpha_field = FieldVal$
  273.  
  274.     px = PXPutAlpha(hrec%, FieldNum%, alpha_field)
  275.     PXError (px)
  276.  
  277.     PutAlphaField = PX_OK
  278.  
  279. End Function
  280.  
  281. Function PutShortField (ByVal TableNum%, ByVal FieldNum%, ByVal ShortVal%) As Integer
  282.     '
  283.     '  Move field to paradox buffer
  284.     '
  285.     hrec% = hRecBuf(TableNum%)
  286.     
  287.     px = PXPutShort(hrec%, FieldNum%, ShortVal%)
  288.     PXError (px)
  289.  
  290.     PutShortField = PX_OK
  291.  
  292. End Function
  293.  
  294. Function PutNumField (ByVal TableNum%, ByVal FieldNum%, ByVal NumVal) As Integer
  295.     Dim nDouble As Double
  296.     '
  297.     '  Move field to paradox buffer
  298.     '
  299.     hrec% = hRecBuf(TableNum%)
  300.     nDouble = NumVal
  301.  
  302.     px = PXPutDoub(hrec%, FieldNum%, nDouble)
  303.     PXError (px)
  304.  
  305.     PutNumField = PX_OK
  306.  
  307. End Function
  308.  
  309. Function GetAlphaField (ByVal TableNum%, ByVal FieldNum%, FieldVal$) As Integer
  310.     Dim IsBlank As Integer
  311.     '
  312.     '  Get field from paradox buffer to user buffer
  313.     '
  314.     hrec% = hRecBuf(TableNum)
  315.  
  316.     px = PXFldBlank(hrec%, FieldNum%, IsBlank)
  317.     PXError (px)
  318.      
  319.     If IsBlank Then
  320.         FieldVal$ = " "
  321.         GetAlphaField = PX_OK
  322.         Exit Function
  323.     End If
  324.         
  325.     px = PXGetAlpha(hrec%, FieldNum%, 255, alpha_field)
  326.     PXError (px)
  327.  
  328.     FieldVal$ = alpha_field
  329.     GetAlphaField = PX_OK
  330. End Function
  331.  
  332. Function GetShortField (ByVal TableNum%, ByVal FieldNum%, ShortVal%) As Integer
  333.     '
  334.     '  Get field from paradox buffer to user buffer
  335.     '
  336.     Dim iShort As Integer
  337.  
  338.     hrec% = hRecBuf(TableNum)
  339.  
  340.     px = PXGetShort(hrec%, FieldNum%, iShort)
  341.     PXError (px)
  342.  
  343.     ShortVal% = iShort
  344.     GetShortField = PX_OK
  345. End Function
  346.  
  347. Function GetNumField (ByVal TableNum%, ByVal FieldNum%, NumVal) As Integer
  348.     '
  349.     '  Get field from paradox buffer to user buffer
  350.     '
  351.     Dim nDouble As Double
  352.  
  353.     hrec% = hRecBuf(TableNum)
  354.  
  355.     px = PXGetDoub(hrec%, FieldNum%, nDouble)
  356.     PXError (px)
  357.  
  358.     NumVal = nDouble
  359.     GetNumField = PX_OK
  360. End Function
  361.  
  362. Function LockRec (ByVal Tblnum%) As Integer
  363.     Dim iLockHandle As Integer
  364.     '
  365.     '  Lock the record that is current  (last one retrieved)
  366.     '
  367.     hTbl% = hTable(Tblnum%)
  368.  
  369.     px = PXNetRecLock(hTbl%, iLockHandle)
  370.     If px = PX_RECLOCKED Then
  371.         LockRec = DB_RECLOCKED
  372.         Exit Function
  373.     End If
  374.     '
  375.     '  check for any other critical error
  376.     '
  377.     PXError (px)
  378.  
  379.     hRecLock(Tblnum%) = iLockHandle
  380.  
  381.     LockRec = px
  382. End Function
  383.  
  384. Function UnlockRec (ByVal Tblnum%) As Integer
  385.     Dim iLockHandle As Integer
  386.     '
  387.     '  Unock a record.
  388.     '  In this version, only one record per table can be
  389.     '  locked at any time.  Could change in the future
  390.     '
  391.     hTbl% = hTable(Tblnum%)
  392.     iLockHandle = hRecLock(Tblnum%)
  393.     '
  394.     '  If no record is locked, exit the function
  395.     '
  396.     If iLockHandle = 0 Then
  397.         UnlockRec = DB_OK
  398.         Exit Function
  399.     End If
  400.     
  401.     px = PXNetRecUnlock(hTbl%, iLockHandle)
  402.     '
  403.     '  If the unlock failed, just go ahead and return
  404.     '  This is REALLY sloppy coding, should be fixed soon
  405.     '
  406.     If px = 110 Then
  407.         UnlockRec = PX_SUCCESS
  408.         Exit Function
  409.     End If
  410.  
  411.     PXError (px)
  412.  
  413.     hRecLock(Tblnum%) = 0
  414.     UnlockRec = px
  415. End Function
  416.  
  417.